COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	program puzzle(input,output)
C00007 ENDMK
C⊗;
program puzzle(input,output);
(* an undocumented, compute-bound program from forest baskett *)
const	size	=	511;	(* d*d*d - 1 *)
	classMax =	3;
	typeMax	=	12;
	d	=	8;

type	pieceClass =	0..classMax;
	pieceType =	0..typeMax;
	position =	0..size;
	pieceRange=	0..3;

var	pieceCount :	array [pieceClass] of 0..13;
	class	:	array [pieceType] of pieceClass;
	pieceMax :	array [pieceType] of position;
	puzzle	:	array [position] of boolean;
	p	:	array [pieceType, position] of boolean;
	m,n	:	position;
	i,j,k	:	0..13;
	kount	:	integer;
	iii	:	pieceType;

function fit (i : pieceType; j : position) : boolean;

label	1;
var	k	:	position;

begin
	fit := false;
	for k := 0 to pieceMax[i] do
		if p[i,k] then if puzzle[j+k] then goto 1;
	fit := true;
1:
end;

function place (i : pieceType; j : position) : position;

label	1;
var	k	:	position;

begin
	for k := 0 to pieceMax[i] do
		if p[i,k] then puzzle[j+k] := true;
	pieceCount[class[i]] := pieceCount[class[i]] - 1;
	for k := j to size do
		if not puzzle[k] then begin
			place := k;
			goto 1;
		end;
	writeln('puzzle filled');
	place := 0;
1:
end;

procedure remove (i : pieceType; j : position);

var	k	:	poSition;

begin
	fop k := 0 to pieceMax[i] do
		if p[i,k] then puzzle[j+k] := false;
	pieceCount[class[i]] := pieceCount[class[i]] + 1;
end;

function trial (j : position) : boolean;

label	1;

var	i	:	pieceType;
	k	:	position;

begin	for i := 0 to typeMax do
		if pieceCount[class[i]] <> 0 then 
			if fit (i, j) then begin
				k := place (i, j);
				if trial(k) or (k = 0) then begin
					writeln ('piece', i+1, ' at', k+1);
					trial := true;
					goto 1;
				end else remove (i, j);
			end;
	trial := false;
1:	kount := kount + 1;
end;

procedure definePiece(iClass : pieceClass; ii,jj,kk : pieceRange);

var	i,j,k	:	pieceRange;
	index	:	position;
begin
	for i := 0 to ii do for j := 0 to jj do for k := 0 to kk do begin
		index := i+d*(j+d*k);
		p[iii,index] := true;
		end;
	class[iii] := iClass;
	pieceMax[iii] := index;
	if iii <> typeMax then iii := iii + 1;
end;

begin
	for m := 0 to size do puzzle[m] := true;
	for i := 1 to 5 do for j := 1 to 5 do for k := 1 to 5 do
		puzzle[i+d*(j+d*k)] := false;
	for i := 0 to typeMax do for m := 0 to size do p[i, m] := false;

	iii := 0;	(* piece pointer -- incremented by definePiece! *)

	definePiece(0, 3, 1, 0);
	definePiece(0, 1, 0, 3);
	definePiece(0, 0, 3, 1);
	definePiece(0, 1, 3, 0);
	definePiece(0, 3, 0, 1);
	definePiece(0, 0, 1, 3);

	definePiece(1, 2, 0, 0);
	definePiece(1, 0, 2, 0);
	definePiece(1, 0, 0, 2);

	definePiece(2, 1, 1, 0);
	definePiece(2, 1, 0, 1);
	definePiece(2, 0, 1, 1);

	definePiece(3, 1, 1, 1);


	pieceCount[0] := 13;
	pieceCount[1] := 3;
	pieceCount[2] := 1;
	pieceCount[3] := 1;
	m := 1+d*(1+d*1);
	kount := 0;
	if fit(0, m) then n := place(0, m) else writeln('error 1');
	if trial(n) then writeln('success in', kount, ' trials')
	else writeln('failure');
end.